perm filename MKVICI.SAI[GEO,BGB] blob
sn#001343 filedate 1972-10-28 generic text, type T, neo UTF8
00100 ENTRY DUMMY;
00200 BEGIN "MKVICI - MAKE VIDEO INTENSITY CONTOUR IMAGE - AUGUST 1972"
00300 REQUIRE "ABBREV[SYS,BGB]" SOURCE_FILE;
00400 REQUIRE "DPYIII[SYS,BGB]" SOURCE_FILE;
00500 INTERNAL SAFE ITG ARRAY HEADER[0:9];
00600 INTERNAL SAFE ITG ARRAY TVBUF [0:10367];
00700
00800 INTERNAL SAFE ITG ARRAY PAC [0:1727];
00900 SAFE ITG ARRAY DPYBUF[0:4000];
01000
01100 α SOURCE WINDOW CENTER;
01200 ITG SX,SY;
01300 REAL SOX,SOY;
01400 α OBJECT WINDOW;
01500 REAL OX,OY,MAG;
01600 α PSEUDO BEAM POSITION;
01700 REAL XXX,YYY;
01800
01900 EXTERNAL SUBR CLIPIN (REAL XL,XH,YL,YH);
02000 EXTERNAL BOOLEAN SUBR CLIP (REFERENCE REAL X1,Y1,X2,Y2);
02100
02200 α DEFINITIONS;
02300
02400 DEFINE mm = "3.2808@-3";
02500 DEFINE PPIOT="'702000000000";
02600 DEFINE THRICE="FOR I←1 STEP 1 UNTIL 3 DO";
02700 DEFINE PUSH= "PADPDL[PDLPTR←PDLPTR+1]";
02800 DEFINE POP = "PADPDL[1+(PDLPTR←PDLPTR-1)]";
02900 DEFINE TOP = "PADPDL[PDLPTR]";
03000 DEFINE ARG1= "PADPDL[PDLPTR-1]";
03100 DEFINE ARG2= "PADPDL[PDLPTR-2]";
03200
03300 EXTERNAL ITG ARRAY PADPDL[0:1000];
03400 EXTERNAL ITG PDLPTR;
00100 α ABBREVIATIONS FOR PROCEDURE DECLARATIONS;
00200 DEFINE XISUBR= "EXTERNAL INTEGER SIMPLE PROCEDURE";
00300 DEFINE XRSUBR= "EXTERNAL REAL SIMPLE PROCEDURE";
00400 DEFINE XSUBR = "EXTERNAL SIMPLE PROCEDURE";
00500 DEFINE ISUBR = "INTEGER SIMPLE PROCEDURE";
00600 DEFINE RSUBR = "REAL SIMPLE PROCEDURE";
00700 DEFINE BSUBR = "BOOLEAN SIMPLE PROCEDURE";
00800
00900 α YE OLDE MNEMONICS;
01000 ISUBR LAC (ITG Q); START_CODE MOVE 1,@Q END;
01100 RSUBR LACR(ITG Q); START_CODE MOVE 1,@Q END;
01200 ISUBR CAR (ITG Q); START_CODE HLRZ 1,@Q END;
01300 ISUBR CDR (ITG Q); START_CODE HRRZ 1,@Q END;
01400 SUBR DAC (ITG N,Q); START_CODE MOVE N; MOVEM @Q END;
01500 SUBR DACR(REAL X;ITG Q);START_CODE MOVE X;MOVEM @Q END;
01600 SUBR DIP (ITG N,Q); START_CODE MOVE N; HRLM @Q END;
01700 SUBR DAP (ITG N,Q); START_CODE MOVE N; HRRM @Q END;
01800 ISUBR NIP (ITG Q); START_CODE HLRE 1,@Q END;
01900 ISUBR NAP (ITG Q); START_CODE HRRE 1,@Q END;
02000 DEFINE INCREM(A)="A←A+1";
02100 DEFINE DECREM(A)="A←A-1";
02200
02300 α FATAL MESSAGE;
02400 SUBR FATAL (STRING S);
02500 ⊂ OUTSTR(↓&"FATAL ERROR - "&S&↓);
02600 WHILE TRUE DO INCHRW ⊃;
02700 α UBFEV NUMBER;
02800 ISUBR ITYPE (ITG X);
02900 RETURN(CASE(CAR(X)LAND '17)OF
03000 (0,1,2,0, 3,0,0,0, 4,0,0,0, 0,0,0,0));
03100 α ENTITY TYPES;
03200 BSUBR BTYPE(ITG X); RETURN((CAR(X)LAND 1)≠0);
03300 BSUBR FTYPE(ITG X); RETURN((CAR(X)LAND 2)≠0);
03400 BSUBR ETYPE(ITG X); RETURN((CAR(X)LAND 4)≠0);
03500 BSUBR VTYPE(ITG X); RETURN((CAR(X)LAND 8)≠0);
03600 α WORLD CONTEXT;
03700 EXTERNAL ITG WORLD,BTOTAL,FTOTAL,ETOTAL,VTOTAL;
00100 SUBR AI(REAL X,Y);⊂ XXX←X*MAG+SOX;YYY←Y*MAG+SOY;⊃;
00200 SUBR AV(REAL X,Y);
00300 BEGIN
00400 REAL X1,Y1,X2,Y2;
00500 X1←XXX;Y1←YYY;X2←XXX←X*MAG+SOX;Y2←YYY←Y*MAG+SOY;
00600 IF CLIP(X1,Y1,X2,Y2) THEN
00700 ⊂ AIVECT(X1,Y1);AVECT(X2,Y2);⊃;
00800 END;
00900
01000 SUBR CROP;
01100 BEGIN "CROP"
01200 REAL OXL,OXH,OYL,OYH;
01300 SOX ← OX - SX*MAG;
01400 SOY ← OY - SY*MAG;
01500 OXL ← (OX - MAG*144*64) MAX -500;
01600 OXH ← (OX + MAG*144*64) MIN 500;
01700 OYL ← (OY - MAG*108*64) MAX -450;
01800 OYH ← (OY + MAG*108*64) MIN 450;
01900 CLIPIN(OXL,OXH,OYL,OYH);
02000 END;
00100 α INPUT A TELEVISION PICTURE;
00200 INTERNAL SUBR TVIN (STRING S);
00300 BEGIN "TVIN"
00400 STRING STR;ITG FLG; LABEL L1,L2;
00500 OPEN(1,"DSK",8,3,0,0,0,0);
00600 STR←S;IF FLG←(LENGTH(STR)=0) THEN GO L2;
00700 L1: LOOKUP(1,STR,FLG);
00800 IF FLG THEN LOOKUP(1,STR&".TMP[DAT,BGB]",FLG);
00900 L2: IF FLG THEN ⊂ OUTSTR(9&"TV FILE = ");
01000 STR←INCHWL;IF LENGTH(STR)=0 THEN RETURN;GO L1;⊃;
01100 ARRYIN(1,HEADER[0],10);
01200 ARRYIN(1,TVBUF[0],10368);
01300 RELEASE(1);
01400 END "TVIN";
00100 INTERNAL SUBR THRESH (ITG CUT);
00200 BEGIN "THRESH"
00300 ITG P1,P2,I;
00400 P1 ← POINT(6,TVBUF[0],-1);
00500 P2 ← POINT(1,PAC[0], -1);
00600 FOR I←0 TO 62207 DO
00700 IF ILDB(P1)≥CUT THEN IDPB(1,P2) ELSE IDPB(0,P2);
00800 END "THRESH";
00900
01000 ITG X0,Y0,X,Y,I,RC,R,C;
01100 ITG CNT,BUF,CUT;
01200 EXTERNAL SUBR PACXOR;
01300 EXTERNAL ITG SUBR MKVIC;
00100 SUBR DPYPGON(ITG P);
00200 BEGIN "DPYPGON"
00300 ITG X,Y,E,E0,V;
00400
00500 SUBR GETXY(ITG V);
00600 BEGIN "GETXY"
00700 RC←LAC(V-1);
00800 R←RC LSH-18; C←RC LAND '777777;
00900 Y←(108*64-R); X←(C-144*64);
01000 END "GETXY";
01100
01200 E←E0←CAR(P+1);V←CAR(E+1);GETXY(V);AI(X,Y);
01300 DO ⊂ V←CDR(E+1);GETXY(V);AV(X,Y); ⊃ UNTIL (E←CDR(V+1))=E0;
01400 END "DPYPGON";
01410
01500 SUBR REFRESH;
01600 BEGIN "REFRESH"
01700 ITG P,E,E0,V,I,CNT;
01800 DPYSET(DPYBUF);AIVECT(-500,-450);AVECT(+500,-450);
01900 AVECT(+500,+450);AVECT(-500,+450);AVECT(-500,-450);
02000 AIVECT(-500,400);DPYBIG(3);DPYSST("CUT = "&CVS(CUT));
02100 FOR I←1 TO PDLPTR DO
02200 BEGIN LABEL L1;
02300 P ← PADPDL[I];
02400 DPYPGON(P);
02500 END;
02600 DPYOUT(0);
02700 END "REFRESH";
00100
00200 ITG CHR,META,CTRL,DEL;
00300 INTERNAL SUBR MOVKEY;
00400 BEGIN "MOVKEY"
00500 LABEL L;
00600
00700 L: CHR ← INCHRW;
00800 IF CHR='175 THEN RETURN;
00900 IF CHR=":" THEN SX←SX+DEL ELSE
01000 IF CHR=";" THEN SX←SX-DEL ELSE
01100 IF CHR=")" THEN SY←SY+DEL ELSE
01200 IF CHR="(" THEN SY←SY-DEL ELSE
01300 IF CHR="/" THEN DEL←(DEL%2)MAX 1 ELSE
01400 IF CHR="\" THEN DEL←(DEL*2) ELSE
01500 IF CHR="*" THEN MAG←MAG*2 ELSE
01600 IF CHR="-" THEN MAG←MAG/2;
01700 CROP;
01800 REFRESH;GO L;
01900
02000 END "MOVKEY";
00100 INTERNAL SUBR MKVICI;
00200 BEGIN "MKVICI"
00250 XISUBR MKPAP; XSUBR SMOOTH(ITG V1,V2;REAL X);
00300 ITG P1,P2,V1,V2,E,CHR; LABEL L;
00400 SX←SY←0;
00500 MAG ← 7/128; DEL ←32*64;
00600 CROP;
00700 PACXOR;
00800 WHILE (P1←MKVIC)≠0 DO
00900 BEGIN
01000 CNT ← ABS(LAC(P1-1));
01100 IF CNT≤10 THEN ⊂ XSUBR KLPGON(ITG I);KLPGON(P1);CONTINUE;⊃;
01200 α AD HOC SMOOTH CALLING;
01300 P2 ← MKPAP;
01400 E ← CAR(P2+1); V1 ← CAR(E+1); V2 ← CDR(E+1);
01500 SMOOTH(V1,V2,0.5); SMOOTH(V2,V1,0.5);
01800
01900 PUSH ← P2;
02000 END;
02100 REFRESH;
02200 MOVKEY;
02300 OUTSTR(↓&" END OF MKVICI."&↓&"o");
02400 END "MKVICI";
02500 END;